home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / ADA / GNAT / !gcc / adainc / 6 / adb / s-valrea < prev    next >
Text File  |  1996-02-12  |  11KB  |  316 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT COMPILER COMPONENTS                         --
  4. --                                                                          --
  5. --                      S Y S T E M . V A L _ R E A L                       --
  6. --                                                                          --
  7. --                                 S p e c                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.12 $                             --
  10. --                                                                          --
  11. --   Copyright (C) 1992,1993,1994,1995,1996 Free Software Foundation, Inc.  --
  12. --                                                                          --
  13. -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14. -- terms of the  GNU General Public License as published  by the Free Soft- --
  15. -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16. -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17. -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18. -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19. -- for  more details.  You should have  received  a copy of the GNU General --
  20. -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21. -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22. -- MA 02111-1307, USA.                                                      --
  23. --                                                                          --
  24. -- As a special exception,  if other files  instantiate  generics from this --
  25. -- unit, or you link  this unit with other files  to produce an executable, --
  26. -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  27. -- covered  by the  GNU  General  Public  License.  This exception does not --
  28. -- however invalidate  any other reasons why  the executable file  might be --
  29. -- covered by the  GNU Public License.                                      --
  30. --                                                                          --
  31. -- GNAT was originally developed  by the GNAT team at  New York University. --
  32. -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  33. --                                                                          --
  34. ------------------------------------------------------------------------------
  35.  
  36. with System.Powten_Table; use System.Powten_Table;
  37. with System.Val_Util;     use System.Val_Util;
  38.  
  39. package body System.Val_Real is
  40.  
  41.    ---------------
  42.    -- Scan_Real --
  43.    ---------------
  44.  
  45.    function Scan_Real
  46.      (Str  : String;
  47.       Ptr  : access Positive'Base;
  48.       Max  : Positive'Base)
  49.       return Long_Long_Float
  50.    is
  51.       P : Positive'Base;
  52.       --  Local copy of string pointer
  53.  
  54.       Base   : Long_Long_Float;
  55.       --  Base value
  56.  
  57.       Uval : Long_Long_Float;
  58.       --  Accumulated float result
  59.  
  60.       subtype Digs is Character range '0' .. '9';
  61.       --  Used to check for decimal digit
  62.  
  63.       Scale : Integer := 0;
  64.       --  Power of Base to multiply result by
  65.  
  66.       Start : Positive;
  67.       --  Position of starting non-blank character
  68.  
  69.       Minus : Boolean;
  70.       --  Set to True if minus sign is present, otherwise to False
  71.  
  72.       Bad_Base : Boolean := False;
  73.       --  Set True if Base out of range or if out of range digit
  74.  
  75.       After_Point : Natural := 0;
  76.       --  Set to 1 after the point
  77.  
  78.       procedure Scanf;
  79.       --  Scans integer literal value starting at current character position.
  80.       --  For each digit encountered, Uval is multiplied by 10.0, and the new
  81.       --  digit value is incremented. In addition Scale is decremented for each
  82.       --  digit encountered if we are after the point (After_Point = 1). The
  83.       --  longest possible syntactically valid numeral is scanned out, and on
  84.       --  return P points past the last character. On entry, the current
  85.       --  character is known to be a digit, so a numeral is definitely present.
  86.  
  87.       procedure Scanf is
  88.          Digit : Natural;
  89.  
  90.       begin
  91.          loop
  92.             Digit := Character'Pos (Str (P)) - Character'Pos ('0');
  93.             Uval := Uval * 10.0 + Long_Long_Float (Digit);
  94.             P := P + 1;
  95.             Scale := Scale - After_Point;
  96.  
  97.             --  Done if end of input field
  98.  
  99.             if P > Max then
  100.                return;
  101.  
  102.             --  Check next character
  103.  
  104.             elsif Str (P) not in Digs then
  105.                if Str (P) = '_' then
  106.                   Scan_Underscore (Str, P, Ptr, Max, False);
  107.                else
  108.                   return;
  109.                end if;
  110.             end if;
  111.          end loop;
  112.       end Scanf;
  113.  
  114.    --  Start of processing for System.Scan_Real
  115.  
  116.    begin
  117.       Scan_Sign (Str, Ptr, Max, Minus, Start);
  118.       P := Ptr.all;
  119.       Ptr.all := Start;
  120.  
  121.       --  If digit, scan numeral before point
  122.  
  123.       if Str (P) in Digs then
  124.          Uval := 0.0;
  125.          Scanf;
  126.  
  127.       --  Initial point, allowed only if followed by digit (RM 3.5(47))
  128.  
  129.       elsif Str (P) = '.'
  130.         and then P < Max
  131.         and then Str (P + 1) in Digs
  132.       then
  133.          Uval := 0.0;
  134.  
  135.       --  Any other initial character is an error
  136.  
  137.       else
  138.          raise Constraint_Error;
  139.       end if;
  140.  
  141.       --  Deal with based case
  142.  
  143.       if P < Max and then (Str (P) = ':' or else Str (P) = '#') then
  144.          declare
  145.             Base_Char : constant Character := Str (P);
  146.             Digit     : Natural;
  147.             Fdigit    : Long_Long_Float;
  148.  
  149.          begin
  150.             if Uval < 2.0 or else Uval > 16.0 then
  151.                Bad_Base := True;
  152.             end if;
  153.  
  154.             Base := Uval;
  155.             Uval := 0.0;
  156.             P := P + 1;
  157.  
  158.             --  Special check to allow initial point (RM 3.5(49))
  159.  
  160.             if Str (P) = '.' then
  161.                After_Point := 1;
  162.                P := P + 1;
  163.             end if;
  164.  
  165.             --  Loop to scan digits of based number. On entry to the loop we
  166.             --  must have a valid digit. If we don't, then we have an illegal
  167.             --  floating-point value, and we raise Constraint_Error, note that
  168.             --  Ptr at this stage was reset to the proper (Start) value.
  169.  
  170.             loop
  171.                if P > Max then
  172.                   raise Constraint_Error;
  173.  
  174.                elsif Str (P) in Digs then
  175.                   Digit := Character'Pos (Str (P)) - Character'Pos ('0');
  176.  
  177.                elsif Str (P) in 'A' .. 'F' then
  178.                   Digit :=
  179.                     Character'Pos (Str (P)) - (Character'Pos ('A') - 10);
  180.  
  181.                elsif Str (P) in 'a' .. 'f' then
  182.                   Digit :=
  183.                     Character'Pos (Str (P)) - (Character'Pos ('a') - 10);
  184.  
  185.                else
  186.                   raise Constraint_Error;
  187.                end if;
  188.  
  189.                P := P + 1;
  190.                Fdigit := Long_Long_Float (Digit);
  191.  
  192.                if Fdigit >= Base then
  193.                   Bad_Base := True;
  194.                else
  195.                   Scale := Scale - After_Point;
  196.                   Uval := Uval * Base + Fdigit;
  197.                end if;
  198.  
  199.                if P > Max then
  200.                   raise Constraint_Error;
  201.  
  202.                elsif Str (P) = '_' then
  203.                   Scan_Underscore (Str, P, Ptr, Max, True);
  204.  
  205.                else
  206.                   --  Skip past period after digit. Note that the processing
  207.                   --  here will permit either a digit after the period, or the
  208.                   --  terminating base character, as allowed in (RM 3.5(48))
  209.  
  210.                   if Str (P) = '.' and then After_Point = 0 then
  211.                      P := P + 1;
  212.                      After_Point := 1;
  213.  
  214.                      if P > Max then
  215.                         raise Constraint_Error;
  216.                      end if;
  217.                   end if;
  218.  
  219.                   exit when Str (P) = Base_Char;
  220.                end if;
  221.             end loop;
  222.  
  223.             --  Based number successfully scanned out (point was found)
  224.  
  225.             Ptr.all := P + 1;
  226.          end;
  227.  
  228.       --  Non-based case, check for being at decimal point now. Note that
  229.       --  in Ada 95, we do not insist on a decimal point being present
  230.  
  231.       else
  232.          Base := 10.0;
  233.          After_Point := 1;
  234.  
  235.          if P <= Max and then Str (P) = '.' then
  236.             P := P + 1;
  237.  
  238.             --  Scan digits after point if any are present (RM 3.5(46))
  239.  
  240.             if P <= Max and then Str (P) in Digs then
  241.                Scanf;
  242.             end if;
  243.          end if;
  244.  
  245.          Ptr.all := P;
  246.       end if;
  247.  
  248.       --  At this point, we have Uval containing the digits of the value as
  249.       --  an integer, and Scale indicates the negative of the number of digits
  250.       --  after the point. Base contains the base value (an integral value in
  251.       --  the range 2.0 .. 16.0). Test for exponent, must be at least one
  252.       --  character after the E for the exponent to be valid.
  253.  
  254.       Scale := Scale + Scan_Exponent (Str, Ptr, Max, Real => True);
  255.  
  256.       --  At this point the exponent has been scanned if one is present and
  257.       --  Scale is adjusted to include the exponent value. Uval contains the
  258.       --  the integral value which is to be multiplied by Base ** Scale.
  259.  
  260.       --  If base is not 10, use exponentiation for scaling
  261.  
  262.       if Base /= 10.0 then
  263.          Uval := Uval * Base ** Scale;
  264.  
  265.       --  For base 10, use power of ten table if in range
  266.  
  267.       elsif Scale > 0 then
  268.          if Scale > Powten'Length then
  269.             Uval := Uval * 10.0 ** Scale;
  270.          else
  271.             Uval := Uval * Powten (Scale);
  272.          end if;
  273.  
  274.       elsif Scale < 0 then
  275.          if (-Scale) > Powten'Length then
  276.             Uval := Uval * 10.0 ** Scale;
  277.          else
  278.             Uval := Uval / Powten (-Scale);
  279.          end if;
  280.       end if;
  281.  
  282.       --  Here is where we check for a bad based number
  283.  
  284.       if Bad_Base then
  285.          raise Constraint_Error;
  286.  
  287.       --  If OK, then deal with initial minus sign, note that this processing
  288.       --  is done even if Uval is zero, so that -0.0 is correctly interpreted.
  289.  
  290.       else
  291.          if Minus then
  292.             return -Uval;
  293.          else
  294.             return Uval;
  295.          end if;
  296.       end if;
  297.  
  298.    end Scan_Real;
  299.  
  300.    ----------------
  301.    -- Value_Real --
  302.    ----------------
  303.  
  304.    function Value_Real (Str : String) return Long_Long_Float is
  305.       V : Long_Long_Float;
  306.       P : aliased Positive'Base := Str'First;
  307.  
  308.    begin
  309.       V := Scan_Real (Str, P'Access, Str'Last);
  310.       Scan_Trailing_Blanks (Str, P);
  311.       return V;
  312.  
  313.    end Value_Real;
  314.  
  315. end System.Val_Real;
  316.